home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Taifun
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf
/
PCQ
/
Source
/
Main.p
< prev
next >
Wrap
Text File
|
1989-03-31
|
9KB
|
363 lines
program PQPascal;
{
PCQ Pascal Compiler
Copyright (c) 1989 Patrick Quaid.
This is the main file of the compiler. When this file is
compiled, it allocates BSS for all the global variables.
}
const
{$I "pasconst.i"}
type
{$I "pastype.i"}
var
{$I "pasvar.i"}
{ The following routines are all exported by the other
compiler files. }
function strlen(s : string): integer;
forward;
function AllocString(l : integer): string;
forward;
procedure error(s : string);
forward;
function findid(s : string): integer;
forward;
function addproc(p : string; i : boolean): integer;
forward;
procedure nextsymbol;
forward;
function match(s : integer): boolean;
forward;
function declvar(r, f : integer) : integer;
forward;
procedure decltype(f : integer);
forward;
procedure declconst(f : integer);
forward;
procedure ns;
forward;
procedure reformargs;
forward;
function readtype(n : integer): integer;
forward;
function endoffile(): boolean;
forward;
procedure vardeclarations(f : integer);
forward;
function reformvars(i : integer): integer;
forward;
procedure outname(s : string);
forward;
procedure initreserved;
forward;
procedure initglobals;
forward;
procedure dumpids;
forward;
procedure dumplits;
forward;
procedure dumptypes;
forward;
procedure trailer;
forward;
procedure compound;
forward;
procedure header;
forward;
procedure initstandard;
forward;
procedure readchar;
forward;
function an(c : char): boolean;
forward;
procedure needrightparent;
forward;
function simpletype(t : integer): boolean;
forward;
procedure openfiles;
{
This routine does all the command line business, which is
at this point not much. It only accepts spaces and tabs as
delimeters, for example, and doesn't take care of quotes or escape
sequences. Furthermore, it doesn't handle any command line
switches. In the future I'll use a routine more like that in
ChopCL.p
}
var
index : integer;
str : string;
begin
index := 1;
while ((commandline[index]= ' ') or (commandline[index] = chr(9)))
and (index <= 128) do
index := index + 1;
if index >= 128 then begin
writeln('Bad file names.');
exit(20);
end;
mainname := string(adr(commandline[index]));
while (commandline[index]<> ' ') and (commandline[index] <> chr(9))
and (index <= 128) do
index := index + 1;
if index >= 128 then begin
writeln('Bad file names.');
exit(20);
end;
commandline[index] := chr(0);
if not reopen(mainname, input) then begin
writeln('Could not open ', mainname);
exit(20);
end;
index := index + 1;
while ((commandline[index]= ' ') or (commandline[index] = chr(9)))
and (index <= 128) do
index := index + 1;
if index >= 128 then begin
writeln('Bad file names.');
exit(20);
end;
str := string(adr(commandline[index]));
while (ord(commandline[index]) > ord(' ')) and
(ord(commandline[index]) < 127) and
(index <= 128) do
index := index + 1;
if index >= 128 then begin
writeln('Bad file names.');
exit(20);
end;
commandline[index] := chr(0);
if not open(str, output) then begin
writeln('Could not open the output file.');
exit(20);
end;
end;
procedure doblock(isfunction : boolean);
{
This is the main routine for handling program, procedure
and function blocks. It handles the various declaration blocks and
the procedure and function parameters. This is one of the many
routines which should, and will, be broken into more manageable
parts.
}
var
blockloc : integer;
blockspell : integer;
firstident : integer;
functype : integer;
index : integer;
varspace : integer;
savefn : integer;
forded : boolean;
begin
fnstart := lineno;
firstident := identptr;
forded := false;
if blocklevel > 0 then begin
if currsym <> ident1 then begin
error("Missing function or procedure name!");
return;
end;
currfn:= findid(symtext);
if currfn <> 0 then begin
if idents[currfn].upper <> 0 then
error("Duplicate ID")
else
forded := true;
end else
currfn := addproc(symtext, isfunction);
nextsymbol;
if match(leftparent1) then begin
prevarg := currfn;
argstk := 0;
while (currsym = ident1) or (currsym = var1) do begin
if match(var1) then
index := declvar(refarg, firstident)
else
index := declvar(valarg, firstident);
if currsym <> rightparent1 then
ns;
end;
idents[currfn].size := argstk;
reformargs;
needrightparent;
end else if isfunction then
error("Functions must have parentheses");
if isfunction then begin
if not match(colon1) then
error("expecting :");
functype := readtype(0);
if functype > 0 then begin
if not simpletype(functype) then begin
error("expecting a simple type");
functype := badtype;
end;
end else
functype := badtype;
idents[currfn].vtype := functype;
end;
ns;
blockloc := identptr;
blockspell := spellptr;
varspace := 0;
end;
if match(forward1) then begin
idents[currfn].upper := 0;
ns;
blockloc := idents[currfn].indtype;
while blockloc <> 0 do begin
idents[blockloc].name := string(adr(spelling));
blockloc := idents[blockloc].indtype;
end;
end else begin
idents[currfn].upper := -1;
while currsym <> begin1 do begin
if endoffile() then begin
if mainmode or (blocklevel > 0) then
error("There was no code section!");
return;
end else if match(var1) then begin
index := identptr - 1;
vardeclarations(firstident);
if blocklevel > 0 then
varspace := reformvars(index);
end else if match(type1) then
decltype(firstident)
else if match(const1) then
declconst(firstident)
else if match(proc1) then begin
blocklevel := blocklevel + 1;
savefn := currfn;
doblock(false);
currfn := savefn;
blocklevel := blocklevel - 1;
end else if match(func1) then begin
blocklevel := blocklevel + 1;
savefn := currfn;
doblock(true);
currfn := savefn;
blocklevel := blocklevel - 1;
end else begin
error("expecting block identifier");
nextsymbol;
end;
end;
if (not mainmode) and (blocklevel = 0) then begin
error("Expected a procedure or function header");
return;
end;
if (blocklevel = 0) and mainmode then begin
writeln(output, "\n\tXDEF\t_MAIN");
writeln(output, '_MAIN');
end;
if blocklevel > 0 then begin
writeln(output, "\n\tXDEF\t_", idents[currfn].name);
writeln(output, '_', idents[currfn].name, "\tlink\ta5,#", varspace);
end;
nextsymbol;
compound;
if blocklevel > 0 then begin
ns;
identptr := blockloc;
spellptr := blockspell;
writeln(output, "\tunlk\ta5");
blockloc := idents[currfn].indtype;
while blockloc <> 0 do begin
idents[blockloc].name := string(adr(spelling));
blockloc := idents[blockloc].indtype;
end;
end;
writeln(output, "\trts");
end;
end;
procedure parse;
{
This is the outermost parsing routine. It uses doblock()
mainly, and will eventually be able to handle program parameters.
}
begin
if match(program1) then begin
mainmode:= true;
if currsym <> ident1 then
error("Missing program name.")
else
writeln('Compiling ', symtext);
while not match(semicolon1) do
nextsymbol;
end else if match(extern1) then begin
mainmode := false;
writeln('Compiling external routines.');
ns;
end else begin
error("First symbol must be PROGRAM or EXTERNAL.");
mainmode:= false;
end;
header;
blocklevel := 0;
doblock(false);
if mainmode then
if not match(period1) then
error("Program must end with a period.");
if (not endoffile()) and (mainmode) then
error("There should be nothing after the main procedure.");
end;
begin
{
This is the big one, the main routine, which by itself does
very little. Read parse() and doblock() to get a much better idea
of how things work.
}
writeln('PCQ Compiler 1.0 (February 1, 1989)');
writeln('Copyright ', chr(169),
' 1989 Patrick Quaid. All rights reserved.');
initglobals; { initialize everything }
initreserved;
openfiles;
initstandard;
readchar; { jump-start lex analysis }
nextsymbol;
parse; { do everything }
if errorcount = 0 then
writeln('There were no errors.')
else if errorcount = 1 then
writeln('There was one error')
else
writeln('There were ', errorcount, ' errors.');
dumpids; { write ids and lits to assem file }
dumplits;
trailer; { write 'END' }
if errorcount <> 0 then
exit(10); { make sure there's an error is necessary }
end.